home *** CD-ROM | disk | FTP | other *** search
/ TeX 1995 July / TeX CD-ROM July 1995 (Disc 1)(Walnut Creek)(1995).ISO / dviware / ln03 / rmcs / cli.for < prev    next >
Text File  |  1989-06-06  |  12KB  |  496 lines
  1.     SUBROUTINE CLI
  2.      
  3. C 
  4. C FUNCTIONAL DESCRIPTION:    
  5. C 
  6. C    Uses Niel Kempson's routines to extract the command line information
  7. C 
  8. C DUMMY ARGUMENTS:
  9. C 
  10. C    none
  11. C 
  12. C IMPLICIT INPUTS:
  13. C 
  14. C    none
  15. C 
  16. C IMPLICIT OUTPUTS:
  17. C 
  18. C    All values in COMMON/GINOTOSIX/ initialized
  19. C 
  20. C 
  21. C SIDE EFFECTS:
  22. C 
  23. C    none
  24. C 
  25. C 
  26.     IMPLICIT NONE
  27.  
  28.     INCLUDE '($SSDEF)'
  29.     INCLUDE '($NAMDEF)'
  30.     
  31.     INTEGER*4    SEGMENT        !Segment number in saved drawing
  32.     REAL*4        WIDTH        !Desired width
  33.     REAL*4        HEIGHT        !Desired height
  34.     REAL*4        SCALE        !Desired scale factor
  35.     CHARACTER*255    INPUT        !Name of input file
  36.     CHARACTER*255    OUTPUT        !Name of output file
  37.     LOGICAL        FORMFEED    !Do we want a formfeed at the end of the
  38.                     !file?
  39.  
  40.     COMMON/GINOTOSIX/INPUT,OUTPUT,WIDTH,HEIGHT,SCALE,SEGMENT,FORMFEED
  41.  
  42.     INTEGER*4    CLI_STATUS
  43.     INTEGER*4    CLI_STRING_LENGTH
  44.     INTEGER*4    FILE_NAME_STATUS_BITS
  45.     INTEGER*4    INPUT_LENGTH
  46.     INTEGER*4    OUTPUT_LENGTH
  47.     INTEGER*4    OUTPUT__LENGTH
  48.     INTEGER*4    PARSE_STATUS
  49.     INTEGER*4    F_DOLLAR_PARSE
  50.     CHARACTER*255    CLI_STRING
  51.     CHARACTER*255    OUTPUT_
  52.     CHARACTER*255    DEFAULT_FILESPEC
  53.     CHARACTER*255    DEFAULT_NAME
  54.     INTEGER*4    DEFAULT_NAME_LENGTH
  55.     INTEGER*4    DEFAULT_TYPE_LENGTH
  56.     INTEGER*4    DEFAULT_FILESPEC_LENGTH
  57.      
  58.     PARAMETER    PARSE_CONCEAL = 0
  59.     PARAMETER    PARSE_NOCONCEAL = 1
  60.     PARAMETER    PARSE_SYNTAX_ONLY = 2
  61.     PARAMETER    PARSE_CHECK_EXISTS = 0
  62.  
  63.     EXTERNAL    CLI$PRESENT
  64.     EXTERNAL    CLI$GET_VALUE
  65.  
  66.     INTEGER*4    CLI$PRESENT
  67.     INTEGER*4    CLI$GET_VALUE
  68.  
  69.     EXTERNAL    CLI$_PRESENT
  70.     EXTERNAL    CLI$_ABSENT
  71.     EXTERNAL    CLI$_NEGATED
  72.     EXTERNAL    CLI$_COMMA
  73.  
  74.     SEGMENT = 0
  75.     CLI_STATUS = CLI$PRESENT ('SEGMENT')
  76.     IF (CLI_STATUS .EQ. %LOC (CLI$_PRESENT)) THEN
  77.         CLI_STATUS = CLI$GET_VALUE ('SEGMENT', 
  78.     1                CLI_STRING, 
  79.     1                CLI_STRING_LENGTH)
  80.         
  81.         IF (CLI_STATUS .EQ. SS$_NORMAL) THEN 
  82.         READ (CLI_STRING(1:CLI_STRING_LENGTH), 110) SEGMENT
  83.         ELSE
  84.         TYPE *,'GINOTOSIX Error - Invalid segment'
  85.         STOP
  86.         END IF
  87.         IF (SEGMENT.LT.0) THEN
  88.         TYPE *,'GINOTOSIX Error - Invalid segment'
  89.         STOP
  90.         END IF
  91.  
  92.     END IF       
  93.  
  94.     SCALE = 0
  95.     CLI_STATUS = CLI$PRESENT ('SCALE')
  96.     IF (CLI_STATUS .EQ. %LOC (CLI$_PRESENT)) THEN
  97.         CLI_STATUS = CLI$GET_VALUE ('SCALE', 
  98.     1                CLI_STRING, 
  99.     1                CLI_STRING_LENGTH)
  100.         
  101.         IF (CLI_STATUS .EQ. SS$_NORMAL) THEN 
  102.         READ (CLI_STRING(1:CLI_STRING_LENGTH), 100, ERR=200) SCALE
  103.         ELSE
  104. 200        TYPE *,'GINOTOSIX Error - Invalid scale'
  105.         STOP
  106.         END IF
  107.  
  108.     END IF       
  109.  
  110.     WIDTH = 0
  111.     HEIGHT = 0
  112.     CLI_STATUS = CLI$PRESENT ('SIZE')
  113.     
  114.     IF (CLI_STATUS .EQ. %LOC (CLI$_PRESENT)) THEN
  115.     
  116.         CLI_STATUS = CLI$GET_VALUE ('SIZE.WIDTH', 
  117.     1                CLI_STRING, 
  118.     1                CLI_STRING_LENGTH)
  119.  
  120.         IF (CLI_STATUS .EQ. SS$_NORMAL) THEN
  121.         READ (CLI_STRING(1:CLI_STRING_LENGTH), 100) WIDTH
  122.         ELSE
  123.         TYPE *,'GINOTOSIX Error - Invalid width'
  124.         STOP
  125.         END IF
  126.     
  127.         CLI_STATUS = CLI$GET_VALUE ('SIZE.HEIGHT', 
  128.     1                CLI_STRING, 
  129.     1                CLI_STRING_LENGTH)
  130.  
  131.         IF (CLI_STATUS .EQ. SS$_NORMAL) THEN 
  132.         READ (CLI_STRING(1:CLI_STRING_LENGTH), 100) HEIGHT
  133.         ELSE
  134.         TYPE *,'GINOTOSIX Error - Invalid height'
  135.         STOP
  136.         END IF
  137.  
  138.     END IF       
  139.  
  140.     CLI_STATUS = CLI$PRESENT ('OUTPUT')
  141.     IF (CLI_STATUS .EQ. %LOC (CLI$_PRESENT)) THEN
  142.         CLI_STATUS = CLI$GET_VALUE (
  143.     1        'OUTPUT', 
  144.     1        OUTPUT_, 
  145.     1        OUTPUT__LENGTH)
  146.  
  147.         PARSE_STATUS = F_DOLLAR_PARSE(
  148.     1        OUTPUT_(1:OUTPUT__LENGTH),
  149.     1        '*.*;*',
  150.     1        'FULL',
  151.     1        PARSE_CONCEAL+PARSE_SYNTAX_ONLY,
  152.     1        OUTPUT,
  153.     1        OUTPUT_LENGTH,
  154.     1        FILE_NAME_STATUS_BITS)
  155.  
  156.         IF (IAND(FILE_NAME_STATUS_BITS, NAM$M_WILD_DIR) .NE. 0) THEN
  157.         TYPE *,'GINOTOSIX Error - Illegal output filespec'
  158.         STOP
  159.         END IF
  160.  
  161.     ELSE
  162.  
  163.         OUTPUT(1:7) = '[]*.*;*'
  164.         OUTPUT(8:) = ' '
  165.         OUTPUT_LENGTH = 7
  166.  
  167.     END IF
  168.  
  169.     CALL REMOVE_WILDCARDS (OUTPUT, OUTPUT_LENGTH)
  170.  
  171.     CLI_STATUS = CLI$GET_VALUE('INPUT_FILESPEC',
  172.     1               INPUT,
  173.     1               INPUT_LENGTH)
  174.  
  175.     IF (CLI_STATUS .NE. SS$_NORMAL) THEN
  176.         TYPE *,'GINOTOSIX Error - Illegal input filespec'
  177.         STOP
  178.     END IF
  179.  
  180.     PARSE_STATUS = F_DOLLAR_PARSE (
  181.     1            INPUT(1:INPUT_LENGTH),
  182.     1                '.PIC',
  183.     1                'FULL',
  184.     1            PARSE_CONCEAL+PARSE_SYNTAX_ONLY,
  185.     1            INPUT,
  186.     1            INPUT_LENGTH,
  187.     1            FILE_NAME_STATUS_BITS)
  188.  
  189.     PARSE_STATUS = F_DOLLAR_PARSE (INPUT,
  190.     1            ' ',
  191.     1            'NAME', 
  192.     1            PARSE_CONCEAL+PARSE_SYNTAX_ONLY,
  193.     1            DEFAULT_NAME,
  194.     1            DEFAULT_NAME_LENGTH,
  195.     1            FILE_NAME_STATUS_BITS)
  196.  
  197.     DEFAULT_FILESPEC = DEFAULT_NAME(1:DEFAULT_NAME_LENGTH) // '.SIX'
  198.     DEFAULT_FILESPEC_LENGTH = DEFAULT_NAME_LENGTH + 4
  199.  
  200.     PARSE_STATUS = F_DOLLAR_PARSE (
  201.     1            OUTPUT(1:OUTPUT_LENGTH),
  202.     1                DEFAULT_FILESPEC(1:DEFAULT_FILESPEC_LENGTH),
  203.     1                'FULL',
  204.     1            PARSE_CONCEAL+PARSE_SYNTAX_ONLY,
  205.     1            OUTPUT,
  206.     1            OUTPUT_LENGTH,
  207.     1            FILE_NAME_STATUS_BITS)
  208.  
  209.     IF (IAND (FILE_NAME_STATUS_BITS, NAM$M_WILDCARD) .NE. 0) THEN
  210.         CALL REMOVE_WILDCARDS (OUTPUT, OUTPUT_LENGTH)
  211.     END IF
  212.  
  213.     FORMFEED=.FALSE.
  214.     CLI_STATUS = CLI$PRESENT ('FORMFEED')
  215.     IF (CLI_STATUS .EQ. %LOC (CLI$_PRESENT)) FORMFEED=.TRUE.
  216.  
  217.     RETURN
  218.     
  219. 100    FORMAT (F5.0)
  220. 110    FORMAT (I5)
  221.     
  222.     END
  223.      
  224.     SUBROUTINE REMOVE_WILDCARDS (FILE_SPEC, FILE_SPEC_LENGTH)
  225.     INCLUDE '($NAMDEF)'
  226.     PARAMETER    PARSE_CONCEAL = 0,
  227.     1        PARSE_NOCONCEAL = 1,
  228.     1        PARSE_SYNTAX_ONLY = 2,
  229.     1        PARSE_CHECK_EXISTS = 0
  230.     CHARACTER*(*)    file_spec
  231.     INTEGER*4    file_spec_length
  232.     CHARACTER*255
  233.     1        new_file_spec,
  234.     1        node,
  235.     1        device,
  236.     1        directory
  237.     CHARACTER*255
  238.     1        default_name,
  239.     1        default_type,
  240.     1        name,
  241.     1        type,
  242.     1        version
  243.     INTEGER*4    new_file_spec_length,
  244.     1        node_length,
  245.     1        device_length,
  246.     1        directory_length,
  247.     1        name_length, 
  248.     1        type_length,
  249.     1        version_length,
  250.     1        f_dollar_parse,
  251.     1        parse_status,
  252.     1        file_name_status_bits,
  253.     1        string_length
  254.  
  255.     
  256.     file_spec_length = string_length (file_spec)
  257.  
  258.     parse_status = f_dollar_parse (
  259.     1            file_spec(1:file_spec_length),
  260.     1                ' ',
  261.     1                'NODE',
  262.     1            PARSE_CONCEAL+PARSE_SYNTAX_ONLY,
  263.     1            node,
  264.     1            node_length,
  265.     1            file_name_status_bits)
  266.     IF (node_length .GT. 0) THEN
  267.         new_file_spec(1:) = node(1:node_length)
  268.     END IF
  269.     new_file_spec_length = node_length
  270.  
  271.     parse_status = f_dollar_parse (
  272.     1            file_spec(1:file_spec_length),
  273.     1                ' ',
  274.     1                'DEVICE',
  275.     1            PARSE_CONCEAL+PARSE_SYNTAX_ONLY,
  276.     1            device,
  277.     1            device_length,
  278.     1            file_name_status_bits    )
  279.     IF (device_length .GT. 0) THEN
  280.         new_file_spec(new_file_spec_length+1:) = device(1:device_length)
  281.     END IF
  282.     new_file_spec_length = new_file_spec_length + device_length
  283.  
  284.     parse_status = f_dollar_parse (
  285.     1            file_spec(1:file_spec_length),
  286.     1                ' ',
  287.     1                'DIRECTORY',
  288.     1            PARSE_CONCEAL+PARSE_SYNTAX_ONLY,
  289.     1            directory,
  290.     1            directory_length,
  291.     1            file_name_status_bits)
  292.  
  293.     IF (IAND (file_name_status_bits, NAM$M_WILD_DIR) .EQ. 0) THEN
  294.         IF (directory_length .GT. 0) THEN
  295.         new_file_spec(new_file_spec_length+1:) = 
  296.     1                    directory(1:directory_length)
  297.         END IF
  298.         new_file_spec_length = new_file_spec_length + directory_length
  299.     END IF
  300.  
  301.     parse_status = f_dollar_parse (
  302.     1            file_spec(1:file_spec_length),
  303.     1                ' ',
  304.     1                'NAME',
  305.     1            PARSE_CONCEAL+PARSE_SYNTAX_ONLY,
  306.     1            name,
  307.     1            name_length,
  308.     1            file_name_status_bits    )
  309.  
  310.     IF (IAND (file_name_status_bits, NAM$M_WILD_NAME) .EQ. 0) THEN
  311.         IF (name_length .GT. 0) THEN
  312.         new_file_spec(new_file_spec_length+1:) = name(1:name_length)
  313.         END IF
  314.         new_file_spec_length = new_file_spec_length + name_length
  315.     END IF
  316.  
  317.     parse_status = f_dollar_parse (
  318.     1            file_spec(1:file_spec_length),
  319.     1                ' ',
  320.     1                'TYPE',
  321.     1            PARSE_CONCEAL+PARSE_SYNTAX_ONLY,
  322.     1            type,
  323.     1            type_length,
  324.     1            file_name_status_bits    )
  325.  
  326.     IF (IAND (file_name_status_bits, NAM$M_WILD_TYPE) .EQ. 0) THEN
  327.         IF (type_length .GT. 0) THEN
  328.         new_file_spec(new_file_spec_length+1:) = type(1:type_length)
  329.         END IF
  330.         new_file_spec_length = new_file_spec_length + type_length
  331.     END IF
  332.  
  333.     parse_status = f_dollar_parse (
  334.     1            file_spec(1:file_spec_length),
  335.     1                ' ',
  336.     1                'VERSION',
  337.     1            PARSE_CONCEAL+PARSE_SYNTAX_ONLY,
  338.     1            version,
  339.     1            version_length,
  340.     1            file_name_status_bits)
  341.  
  342.     IF (IAND (file_name_status_bits, NAM$M_WILD_VER) .EQ. 0) THEN
  343.         IF (version_length .GT. 0) THEN
  344.         new_file_spec(new_file_spec_length+1:) = 
  345.     1                    version(1:version_length)
  346.         END IF
  347.         new_file_spec_length = new_file_spec_length + version_length
  348.     END IF
  349.  
  350.     IF (new_file_spec_length .GT. 0) THEN
  351.         file_spec(1:) = new_file_spec(1:new_file_spec_length)
  352.     END IF
  353.     file_spec_length = new_file_spec_length
  354.  
  355.     RETURN
  356.     END
  357.  
  358.     INTEGER*4 FUNCTION f_dollar_parse (file_spec, 
  359.     1                default_file_spec,
  360.     1                parse_type,
  361.     1                parse_flags,
  362.     1                return_buffer, 
  363.     1                return_string_length,
  364.     1                file_name_status_bits)
  365.     INCLUDE '($FABDEF)'
  366.     INCLUDE '($NAMDEF)'
  367.     PARAMETER    PARSE_CONCEAL = 0,
  368.     1        PARSE_NOCONCEAL = 1,
  369.     1        PARSE_SYNTAX_ONLY = 2,
  370.     1        PARSE_CHECK_EXISTS = 0
  371.     CHARACTER*(*)    file_spec,
  372.     1        default_file_spec,
  373.     1        return_buffer,
  374.     1        parse_type
  375.     INTEGER*4    return_string_length,
  376.     1        parse_flags,
  377.     1        file_name_status_bits
  378.     RECORD /FABDEF/ fab
  379.     RECORD /NAMDEF/ nam
  380.     CHARACTER*16    local_parse_type
  381.     CHARACTER*255
  382.     1        full_filespec    
  383.     INTEGER*4    SYS$PARSE,
  384.     1        start_char, 
  385.     1        stop_char, 
  386.     1        return_buffer_size,
  387.     1        parsed_string_length
  388.     BYTE        int_to_byte
  389.  
  390.     fab.FAB$B_BID = FAB$C_BID
  391.     fab.FAB$B_BLN = FAB$C_BLN
  392.  
  393.     fab.FAB$L_FNA = %LOC (file_spec)
  394.     fab.FAB$B_FNS = int_to_byte (LEN (file_spec))
  395.  
  396.     fab.FAB$L_DNA = %LOC (default_file_spec)
  397.     fab.FAB$B_DNS = int_to_byte (LEN (default_file_spec))
  398.  
  399.     fab.FAB$L_NAM = %LOC (nam)
  400.  
  401.     nam.NAM$B_BID = NAM$C_BID
  402.     nam.NAM$B_BLN = NAM$C_BLN
  403.  
  404.     nam.NAM$L_ESA = %LOC (full_filespec)
  405.     nam.NAM$B_ESS = int_to_byte (MIN (LEN (full_filespec), 255))
  406.  
  407.     nam.NAM$B_NOP = 0
  408.  
  409.     IF (IAND (parse_flags, PARSE_NOCONCEAL) .NE. 0) THEN
  410.         nam.NAM$B_NOP = NAM$M_NOCONCEAL
  411.     END IF 
  412.  
  413.     IF (IAND (parse_flags, PARSE_SYNTAX_ONLY) .NE. 0) THEN
  414.         nam.NAM$B_NOP = nam.NAM$B_NOP + NAM$M_SYNCHK
  415.     END IF
  416.  
  417.     f_dollar_parse = SYS$PARSE (fab)
  418.     file_name_status_bits = nam.NAM$L_FNB    
  419.  
  420.     CALL STR$UPCASE (local_parse_type, parse_type)
  421.  
  422.     IF (local_parse_type .EQ. 'NODE') THEN
  423.         start_char = nam.NAM$L_NODE - nam.NAM$L_ESA + 1
  424.         stop_char = start_char + ZEXT (nam.NAM$B_NODE) - 1
  425.  
  426.     ELSE IF (local_parse_type .EQ. 'DEVICE') THEN
  427.         start_char = nam.NAM$L_DEV - nam.NAM$L_ESA + 1
  428.         stop_char = start_char + ZEXT (nam.NAM$B_DEV) - 1
  429.  
  430.     ELSE IF (local_parse_type .EQ. 'DIRECTORY') THEN
  431.         start_char = nam.NAM$L_DIR - nam.NAM$L_ESA + 1
  432.         stop_char = start_char + ZEXT (nam.NAM$B_DIR) - 1
  433.  
  434.     ELSE IF (local_parse_type .EQ. 'NAME') THEN
  435.         start_char = nam.NAM$L_NAME - nam.NAM$L_ESA + 1
  436.         stop_char = start_char + ZEXT (nam.NAM$B_NAME) - 1
  437.  
  438.     ELSE IF (local_parse_type .EQ. 'TYPE') THEN
  439.         start_char = nam.NAM$L_TYPE - nam.NAM$L_ESA + 1
  440.         stop_char = start_char + ZEXT (nam.NAM$B_TYPE) - 1
  441.  
  442.     ELSE IF (local_parse_type .EQ. 'VERSION') THEN
  443.         start_char = nam.NAM$L_VER - nam.NAM$L_ESA + 1
  444.         stop_char = start_char + ZEXT (nam.NAM$B_VER) - 1
  445.  
  446.     ELSE IF (local_parse_type .EQ. 'FULL') THEN
  447.         start_char = 1
  448.         stop_char = ZEXT (nam.NAM$B_ESL)
  449.  
  450.     ELSE
  451.         TYPE *, 'Invalid parse string: (',local_parse_type,').'
  452.         CALL LIB$SIGNAL (MODIFY$INVPARTYP, 1, local_parse_type)
  453.         CALL EXIT
  454.     END IF        
  455.     
  456.     parsed_string_length = stop_char - start_char + 1
  457.     return_buffer_size = LEN (return_buffer)
  458.     return_string_length = MIN (return_buffer_size, parsed_string_length)
  459.  
  460.     IF (return_string_length .GT. 0) THEN
  461.         return_buffer(1:) = full_filespec(
  462.     1    start_char:start_char + return_string_length - 1)
  463.     END IF
  464.  
  465.     RETURN
  466.     END
  467.  
  468.     INTEGER*4 FUNCTION string_length (string)
  469.     IMPLICIT NONE
  470.     CHARACTER*(*)    string
  471.     CHARACTER    this_char
  472.     string_length = LEN (string)
  473.  
  474.     DO WHILE (string_length .GT. 0)
  475.         this_char = string(string_length:string_length)
  476.         IF ((this_char .NE. ' ') .AND. (this_char .NE. CHAR(9))) THEN
  477.         RETURN
  478.         END IF
  479.         string_length = string_length - 1
  480.     END DO
  481.     RETURN
  482.     END
  483.  
  484.     BYTE FUNCTION int_to_byte (number)
  485.     IMPLICIT NONE
  486.     INTEGER*4 number
  487.  
  488.     IF ( IAND (number, '00000080'X) .NE. 0) THEN
  489.         int_to_byte = IOR (number, 'FFFFFF00'X)
  490.     ELSE
  491.         int_to_byte = IAND (number, '000000FF'X)
  492.     END IF
  493.     
  494.     RETURN
  495.     END
  496.